(** simple data container, intended for histograms; 
 should be applied for the most of interfaces to histograms *)

open Glob.Inc

module type Acc_def = 
  sig 
      type result 
      type elt
      val fill: result -> elt -> unit
  end


(** basic histogram definitions *)
module type Hist_def = 
    sig 
        include Acc_def
        val wrap_hist: elt -> Histo.hist
        val clear: elt -> unit
        val name_of: elt -> string
    end

module H1_t =
    struct
            type result = float * float
            type elt = Histo.H1.t
            let fill (x,w) h = Histo.H1.fill x w h
            let wrap_hist h = Histo.H1d h
            let clear = Histo.H1.clear
            let name_of h = h.Histo.H1.info.Histo.name
    end

module H2_t =
    struct
            type result = float * float * float
            type elt = Histo.H2.t
            let fill (x,y,w) h = Histo.H2.fill x y w h
            let wrap_hist h = Histo.H2d h
            let clear = Histo.H2.clear
            let name_of h = h.Histo.H2.info.Histo.name
    end
;;
module Result = struct
  type 'a misc_result = Result of 'a | List_results of 'a list
  exception Hist_not_defined
  module Result_common(HD: Hist_def) = struct
      let fill_misc result hist = (
          match result with
              Result r -> 
                  HD.fill r hist
            | List_results l ->
                  List.iter (fun r -> HD.fill r hist) l
      )
      let fill_misc_opt result hist' = (
          match hist' with
              Some hist -> fill_misc result hist
            | None -> raise Hist_not_defined
      )
  end
  module RH1 = Result_common(H1_t)
  module RH2 = Result_common(H2_t)
end
open Result
module Common = struct
  let select1d (result: H2_t.result misc_result) = function
      Histo.X -> (match result with 
          Result (x,y,w) -> Result (x,w)
        | List_results l -> List_results (List.map (fun (x,y,w) -> (x,w)) l))
    | Histo.Y -> (match result with
          Result (x,y,w) -> Result (y,w)
        | List_results l -> List_results (List.map (fun (x,y,w) -> (y,w)) l))
  ;;
  let unify result1 result2 =
      ( match result1 with
          Result r1 ->
              ( match result2 with
                  Result r2 -> List_results [r1;r2]
                | List_results l2 -> List_results (r1::l2))
        | List_results l1 ->
              ( match result2 with
                  Result r2 -> List_results (r2::l1)
                | List_results l2 -> List_results (l1@l2))
      )
end
open Common

module Make 
    ( Event: sig
        type t
        val is_online: unit -> bool 
(*        val iter: (t -> unit) ref *)
(*        type hit *)
      end )
= struct
  type func = 
      [ `H1T of (Event.t -> H1_t.result misc_result) 
      | `H2T of (Event.t -> H2_t.result misc_result) 
      | `Graph ]
  let maybe_online a = if Event.is_online () then `Graph else a
  module H1_t' = struct 
      include H1_t
      let wrap_fun f = maybe_online (`H1T f)
  end
  module H2_t' = struct 
      include H2_t
      let wrap_fun f = maybe_online (`H2T f)
  end

(*  type s = Histo.hist * func*)
  module H_base = 
      Histo_dir.Make
        ( struct
            type t = Histo.hist * func
            let hist (hf: t) = fst hf
        end )
  type container = H_base.histo_container

  module type Hist_def' = 
    sig 
        include Hist_def
        val wrap_fun: (Event.t -> result misc_result) -> func
    end
  module type D_t = sig type t = private [> H_base.content ] end
  module Make_common_defs (HD: Hist_def')
          (D: D_t) = struct
      include Result_common(HD)
      class elt a = object
          val a = a
          method clear = HD.clear a
          method name = HD.name_of a
      end
      class arr ~init ~n = object
          val hists = Array.init n init
          method clear = Array.iter HD.clear hists
      end
      class virtual matr ~name ~init ~n1 ~n2 = object(self)
          val hists = Matrix.init n1 n2 init
          method clear = Matrix.iter HD.clear hists
          method virtual get_result: 
                Event.t -> int * int -> HD.result misc_result 
          method get_container : D.t =
              let matrix = Matrix.map_ij (fun (i,j) hist ->
                  (HD.wrap_hist hist),
                  (HD.wrap_fun (fun e -> self#get_result e (i,j)))
              ) hists
              in `Matrix_picture (n1,n2,name,matrix)
      end
      class virtual opt_matr ~name ~init ~n1 ~n2 = object(self)
          val hists = Matrix.init n1 n2 init
          method clear = Matrix.iter (maybe HD.clear) hists
          method virtual get_result: 
                Event.t -> int * int -> HD.result misc_result 
          method get_container : D.t =
              let f (i,j) hist =
                  (HD.wrap_hist hist),
                  (HD.wrap_fun (fun e -> self#get_result e (i,j))) in
              let matrix = Matrix.map_ij 
                  (fun (i,j) hist -> maybe_opt (f (i,j)) hist)
                  hists
              in `Opt_matrix_picture (n1,n2,name,matrix)
      end
  end
(*
  module Make_functions(D: D_t) = struct
      module F1 = Make_common_defs(H1_t')(D)
      module F2 = Make_common_defs(H2_t')(D)
  end
*)
  module ID(T: sig type hit end) = 
      struct type t = Event.t let convert (e: t) = e type hit = T.hit end

(*  module Init_dir (D: sig type 'a dir = private [> 'a H_base.dir ] end)*)
  module Init_dir (D: sig 
      type t = private [> H_base.content ] 
      val name_of: t -> string 
  end)
  (IM: sig type t val convert: Event.t -> t type hit end)
      =
  struct
    module Dir = Directory.Find_print_make(D)
    type basic_cls = 
      < fill: IM.t -> unit; 
(*        get_container: 'a. 'a D.dir; *)
        get_container: Dir.content; 
        clear: unit;
        >
    type filter_elt = IM.t -> IM.hit
    type filter_arr = IM.t -> int -> IM.hit
    type filter_matr = IM.t -> int * int -> IM.hit
    module Common_FULL (HD: Hist_def') = struct
        module C = Make_common_defs(HD)(D)
        class virtual elt a = 
        object(self) inherit C.elt a
            method virtual get_result': IM.t -> HD.result misc_result
            method get_result e = self#get_result' (IM.convert e)
            method fill e = 
                C.fill_misc (self#get_result' e) a
            method get_container =
                let hf = (HD.wrap_hist a), (HD.wrap_fun self#get_result)
                in `Elt hf
            method coerce = (self :> basic_cls)
        end
        class virtual arr ~name ~init ~n =
        object(self) inherit C.arr ~init ~n
            method virtual get_result': IM.t -> int -> HD.result misc_result 
            method get_result e i = self#get_result' (IM.convert e) i
            method fill e =
                Array.iteri (fun i hist ->
                    C.fill_misc (self#get_result' e i) hist
                ) hists
            method get_container = 
                let hfl = Array.mapi (fun i hist ->
                    (HD.wrap_hist hist), 
                    (HD.wrap_fun (fun e -> self#get_result e i))
                ) hists 
                in `Array_picture (n,name,hfl)
            method coerce = (self :> basic_cls)
        end
        class virtual matr ~name ~init ~n1 ~n2 =
        object(self) inherit C.matr ~name ~init ~n1 ~n2
            method virtual get_result': 
                IM.t -> int * int -> HD.result misc_result 
            method get_result e p = self#get_result' (IM.convert e) p
            method fill e = 
                for i1 = 0 to n1-1 do
                    for i2 = 0 to n2-1 do
                        C.fill_misc (self#get_result' e (i1,i2)) 
                             hists.(i1).(i2)
                    done;
                done
            method coerce = (self :> basic_cls)
        end
        class virtual opt_matr ~name ~init ~n1 ~n2 =
        object(self) inherit C.opt_matr ~name ~init ~n1 ~n2
            method virtual get_result': 
                IM.t -> int * int -> HD.result misc_result 
            method get_result e p = self#get_result' (IM.convert e) p
            method fill e = 
                for i1 = 0 to n1-1 do
                    for i2 = 0 to n2-1 do
                        C.fill_misc_opt (self#get_result' e (i1,i2)) 
                             hists.(i1).(i2)
                    done;
                done
            method coerce = (self :> basic_cls)
        end
    end

    module FULL_VAR = struct
       module MAKE (HD: Hist_def') = struct
           module FULL = Common_FULL(HD)
           class elt ~(filter: filter_elt) ~process a = 
           object
               inherit FULL.elt a
               method get_result' e = process (filter e)
           end
           class arr ~name ~(filter: filter_arr) ~process ~init ~n =
           object
               inherit FULL.arr ~name ~init ~n
               method get_result' e i = process (filter e i)
           end
           class matr ~name ~(filter: filter_matr)
           ~process ~init ~n1 ~n2 =
           object(self)
               inherit FULL.matr ~name ~init ~n1 ~n2
               method get_result' e i = process (filter e i)
           end
           class opt_matr ~name ~(filter: filter_matr)
           ~process ~init ~n1 ~n2 =
           object(self)
               inherit FULL.matr ~name ~init ~n1 ~n2
               method get_result' e i = process (filter e i)
           end
           let elt ~filter ~process a = 
               (new elt ~filter ~process a)#coerce
           let arr ~name ~n ~filter ~init ~process = 
               (new arr ~name ~filter ~process ~init ~n)#coerce
           let matr ~name ~n1 ~n2 ~filter ~init ~process = 
               (new matr ~name ~filter ~process ~init ~n1 ~n2)#coerce
           let opt_matr ~name ~n1 ~n2 ~filter ~init ~process = 
               (new opt_matr ~name ~filter ~process ~init ~n1 ~n2)#coerce
           let obj = object method elt = elt method arr = arr 
               method matr = matr method opt_matr = opt_matr end
       end
       module H1 = MAKE (H1_t')
       module H2 = MAKE (H2_t')
       let obj = object method h1 = H1.obj method h2 = H2.obj end
    end
    module FULL_CORR = struct
        module MAKE (HD: Hist_def') = struct
            module FULL = Common_FULL(HD)
            class elt ~(filter1: filter_elt) 
            ~(filter2: filter_elt) ~process a = 
            object 
                inherit FULL.elt a
                method get_result' e = process ((filter1 e), (filter2 e))
            end
           class arr ~name ~(filter1: filter_arr) ~(filter2: filter_arr)
            ~process ~init ~n =
            object
                inherit FULL.arr ~name ~init ~n
                method get_result' e i = 
                    let h1 = filter1 e i and h2 = filter2 e i in
                    process (h1, h2) 
            end
           class matr ~name ~(filter1: filter_matr) ~(filter2: filter_matr)
            ~process ~init ~n1 ~n2 =
            object
                inherit FULL.matr ~name ~init ~n1 ~n2
                method get_result' e p =
                    let h1 = filter1 e p and h2 = filter2 e p in
                    process (h1, h2)
            end
           class opt_matr ~name ~(filter1: filter_matr) ~(filter2: filter_matr)
            ~process ~init ~n1 ~n2 =
            object
                inherit FULL.opt_matr ~name ~init ~n1 ~n2
                method get_result' e p =
                    let h1 = filter1 e p and h2 = filter2 e p in
                    process (h1, h2)
            end
           let elt ~filter1 ~filter2 ~process a = 
               (new elt ~filter1 ~filter2 ~process a)#coerce
           let arr ~name ~filter1 ~filter2 ~init ~n ~process = 
               (new arr ~name ~filter1 ~filter2 ~process ~init ~n)#coerce
           let matr ~name ~filter1 ~filter2 ~init ~n1 ~n2 ~process = 
               (new matr ~name ~filter1 ~filter2 ~process ~init ~n1 ~n2)#coerce
           let opt_matr ~name ~filter1 ~filter2 ~init ~n1 ~n2 ~process = 
               (new opt_matr ~name ~filter1 ~filter2 ~process ~init ~n1 ~n2)#coerce
           let obj = object method elt = elt method arr = arr 
               method matr = matr end
        end
        module H1 = MAKE (H1_t')
        module H2 = MAKE (H2_t')
        let obj = object method h1 = H1.obj method h2 = H2.obj end
    end
    let full = object method var = FULL_VAR.obj 
            method corr = FULL_CORR.obj end
    module MAKE_AUTO 
        ( Input: sig type t end ) (** t = IM.hit or IM.hit * IM.hit *)
        ( I: sig 
            val iter: (Input.t -> unit) -> IM.t -> unit
          end ) = 
    struct
        let fold f init e =
            let acc = ref init in
            I.iter (fun hh -> acc := f !acc hh) e;
            !acc
        module MAKE (HD: Hist_def') = struct
            module C = Make_common_defs(HD)(D)
            class elt ~process ?(place = fun _ -> true) a =
            object(self) inherit C.elt a
                method fill1 hh =
                    if place hh then (C.fill_misc (process hh) a);
                method fill e = I.iter self#fill1 e
                method get_result' e =
                    fold (fun acc hh -> 
                        if place hh 
                        then unify acc (process hh)
                        else acc
                    ) (List_results []) e
                method get_result e = self#get_result' (IM.convert e) 
                method get_container = 
                    let hf = (HD.wrap_hist a), (HD.wrap_fun self#get_result)
                    in `Elt hf
                method coerce = (self :> basic_cls)
            end
            class arr ~name ~process ~place ~init ~n =
	    object(self) inherit C.arr ~init ~n
                method fill1 hh =
                    ( match place hh with
                        Some i -> 
                            C.fill_misc (process hh) hists.(i)
                      | None -> ())
                method get_result' e j =
                    fold (fun acc hh -> 
                        ( match place hh with
                            Some i when i = j -> 
                                unify acc (process hh)
                          | _ -> acc)
                    ) (List_results []) e
                method get_result e j = self#get_result' (IM.convert e) j
                method fill e = I.iter self#fill1 e
                method get_container =
                    let hfa = Array.mapi (fun i hist ->
                        (HD.wrap_hist hist),
                        (HD.wrap_fun (fun e -> self#get_result e i))
                    ) hists
                    in `Array_picture (n,name,hfa)
                method coerce = (self :> basic_cls)
	    end
            class matr ~name ~process ~place ~init ~n1 ~n2 =
            object(self) inherit C.matr ~name ~init ~n1 ~n2
                method fill1 hh =
                    ( match place hh with
                        Some (i,j) ->
                            C.fill_misc (process hh) hists.(i).(j)
                      | None -> ())
                method get_result' e (i,j) =
                    fold (fun acc hh ->
                        ( match place hh with
                            Some (i',j') when (i',j') = (i,j) ->
                                unify acc (process hh)
                          | _ -> acc)
                    ) (List_results []) e
                method get_result e (i,j) = 
                    self#get_result' (IM.convert e) (i,j)
                method fill e = I.iter self#fill1 e
                method coerce = (self :> basic_cls)
            end
            class opt_matr ~name ~process ~place ~init ~n1 ~n2 =
            object(self) inherit C.opt_matr ~name ~init ~n1 ~n2
                method fill1 hh =
                    ( match place hh with
                        Some (i,j) ->
                            (try 
                            C.fill_misc_opt (process hh) hists.(i).(j)
                            with Hist_not_defined -> 
                                failwith (
                                    Printf.sprintf 
                                    "hist. No %i, %i is not defined\n"
                                    i j);
                            )
                      | None -> ())
                method get_result' e (i,j) =
                    fold (fun acc hh ->
                        ( match place hh with
                            Some (i',j') when (i',j') = (i,j) ->
                                unify acc (process hh)
                          | _ -> acc)
                    ) (List_results []) e
                method get_result e (i,j) = 
                    self#get_result' (IM.convert e) (i,j)
                method fill e = I.iter self#fill1 e
                method coerce = (self :> basic_cls)
            end
            let elt ?place ~process a = 
                (new elt ~process ?place a)#coerce
            let arr ~name ~n ~place ~init ~process = 
                (new arr ~name ~process ~place ~init ~n)#coerce
            let matr ~name ~n1 ~n2 ~place ~init ~process = 
               (new matr ~name ~process ~place ~init ~n1 ~n2)#coerce
            let opt_matr ~name ~n1 ~n2 ~place ~init ~process = 
               (new opt_matr ~name ~process ~place ~init ~n1 ~n2)#coerce
            let obj = object method elt = elt method arr = arr 
                method matr = matr end
        end
        module H1 = MAKE (H1_t')
        module H2 = MAKE (H2_t')
        let obj = object method h1 = H1.obj method h2 = H2.obj end
    end
    module AUTO_CORR = MAKE_AUTO(struct type t = IM.hit * IM.hit end)
    module AUTO_VAR = MAKE_AUTO(struct type t = IM.hit end)
    let fill_im o e = 
        let e' = IM.convert e in
        o#fill e'
    let fill_im_list l e = 
        let e' = IM.convert e in
        List.iter (fun o -> o#fill e') l
    let list_to_directory name l =
        `Directory ( name,
            List.map (fun (o: basic_cls) -> o#get_container) l
        )
    let clear_list l =
        List.iter (fun (o: basic_cls) -> o#clear) l
  end
end

